home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue64 / Alfresco / TstMedn.dpr < prev    next >
Encoding:
Text File  |  2000-10-23  |  6.6 KB  |  222 lines
  1. {*********************************************************}
  2. {* TstMedn                                               *}
  3. {* Copyright (c) Julian M Bucknall 2000                  *}
  4. {* All rights reserved.                                  *}
  5. {*********************************************************}
  6. {* Algorithms Alfresco: Percentile calculator            *}
  7. {*********************************************************}
  8.  
  9. {Note: this unit is released as freeware. In other words, you are free
  10.        to use this unit in your own applications, however I retain all
  11.        copyright to the code. JMB}
  12.  
  13. program TstMedn;
  14.  
  15. {$IFDEF Windows}
  16. !! Error - 32-bit only
  17. {$ENDIF}
  18.  
  19. {$APPTYPE CONSOLE}
  20.  
  21. uses
  22.   Windows,
  23.   SysUtils;
  24.  
  25. const
  26.   MaxEIndex = 9999;
  27.  
  28. type
  29.   TDataElement = double;
  30.  
  31.   TLessFunction = function (const X, Y : TDataElement) : boolean;
  32.     {function prototype to compare two items and return true if item X
  33.      is STRICTLY LESS than item Y}
  34.  
  35. type
  36.   PDataArray = ^TDataArray;
  37.   TDataArray = array [0..MaxEIndex] of TDataElement;
  38.  
  39. procedure RandomizeSA(var SA : PDataArray);
  40. var
  41.   i : integer;
  42. begin
  43.   for i := 0 to MaxEIndex do
  44.     SA^[i] := Trunc(Random * 1.0e6);
  45. end;
  46.  
  47.  
  48. function LessThan(const X, Y : TDataElement) : boolean;
  49. begin
  50.   Result := X < Y;
  51. end;
  52.  
  53. function CalcPercentile(var aItemArray    : array of TDataElement;
  54.                             aLeft, aRight : integer;
  55.                             aLessThan     : TLessFunction;
  56.                             aPosn         : integer) : TDataElement;
  57.   function Partition(L, R : integer): integer;
  58.   var
  59.     i, j : integer;
  60.     Last : TDataElement;
  61.     Temp : TDataElement;
  62.   begin
  63.     {set up the indexes}
  64.     i := L;
  65.     j := pred(R);
  66.     {get the partition element}
  67.     Last := aItemArray[R];
  68.     {do forever (we'll break out of the loop when needed)}
  69.     while true do begin
  70.       {find the first element greater than or equal to the partition
  71.        element from the left; note that our partition element will
  72.        stop this loop}
  73.       while aLessThan(aItemArray[i], Last) do
  74.         inc(i);
  75.       {find the first element less than the partition element from the
  76.        right; check to break out of the loop if we hit the left
  77.        element - we have no sentinel there}
  78.       while aLessThan(Last, aItemArray[j]) do begin
  79.         if (j = L) then
  80.           Break;
  81.         dec(j);
  82.       end;
  83.       {if we crossed get out of this infinite loop to swap the
  84.        partition element into place}
  85.       if (i >= j) then
  86.         Break;
  87.       {otherwise swap the two out-of-place elements}
  88.       Temp := aItemArray[i];
  89.       aItemArray[i] := aItemArray[j];
  90.       aItemArray[j] := Temp;
  91.       {and continue}
  92.       inc(i);
  93.       dec(j);
  94.     end;
  95.     {swap the partition element into place, return the dividing index}
  96.     aItemArray[R] := aItemArray[i];
  97.     aItemArray[i] := Last;
  98.     Result := i;
  99.   end;
  100. var
  101.   DividingItem : integer;
  102. begin
  103.   Assert(aLeft < aRight,
  104.          'the left index should be smaller than the right');
  105.   Assert((aLeft <= aPosn) and (aPosn <= aRight),
  106.          'the position required should be between the left and right indexes');
  107.   while (aLeft < aRight) do begin
  108.     {partition about the final element in the set}
  109.     DividingItem := Partition(aLeft, aRight);
  110.     {select which part to further partition}
  111.     if (DividingItem = aPosn) then begin
  112.       Result := aItemArray[DividingItem];
  113.       Exit;
  114.     end;
  115.     if (DividingItem < aPosn) then
  116.       aLeft := succ(DividingItem)
  117.     else
  118.       aRight := pred(DividingItem);
  119.   end;
  120.   Result := aItemArray[aLeft];
  121. end;
  122.  
  123. procedure UsualQuickSort(var aItemArray    : array of TDataElement;
  124.                              aLeft, aRight : integer;
  125.                              aLessThan     : TLessFunction);
  126.   function Partition(L, R : integer): integer;
  127.   var
  128.     i, j : integer;
  129.     Last : TDataElement;
  130.     Temp : TDataElement;
  131.   begin
  132.     {set up the indexes}
  133.     i := L;
  134.     j := pred(R);
  135.     {get the partition element}
  136.     Last := aItemArray[R];
  137.     {do forever (we'll break out of the loop when needed)}
  138.     while true do begin
  139.       {find the first element greater than or equal to the partition
  140.        element from the left; note that our partition element will
  141.        stop this loop}
  142.       while aLessThan(aItemArray[i], Last) do
  143.         inc(i);
  144.       {find the first element less than the partition element from the
  145.        right; check to break out of the loop if we hit the left
  146.        element - we have no sentinel there}
  147.       while aLessThan(Last, aItemArray[j]) do begin
  148.         if (j = L) then
  149.           Break;
  150.         dec(j);
  151.       end;
  152.       {if we crossed get out of this infinite loop to swap the
  153.        partition element into place}
  154.       if (i >= j) then
  155.         Break;
  156.       {otherwise swap the two out-of-place elements}
  157.       Temp := aItemArray[i];
  158.       aItemArray[i] := aItemArray[j];
  159.       aItemArray[j] := Temp;
  160.       {and continue}
  161.       inc(i);
  162.       dec(j);
  163.     end;
  164.     {swap the partition element into place, return the dividing index}
  165.     aItemArray[R] := aItemArray[i];
  166.     aItemArray[i] := Last;
  167.     Result := i;
  168.   end;
  169.   procedure QuickSortPrim(L, R : integer);
  170.   var
  171.     DividingItem : integer;
  172.   begin
  173.     {stop the recursion, if needed}
  174.     if (R - L) <= 0 then
  175.       Exit;
  176.     {otherwise, partition about the final element in the set}
  177.     DividingItem := Partition(L, R);
  178.     {recursively quicksort the two subsets either side of the dividing
  179.      element}
  180.     QuicksortPrim(L, pred(DividingItem));
  181.     QuicksortPrim(succ(DividingItem), R);
  182.   end;
  183. begin
  184.   {start it all off}
  185.   QuicksortPrim(aLeft, aRight);
  186. end;
  187.  
  188.  
  189. var
  190.   SA : PDataArray;
  191.   i  : integer;
  192.   Value : TDataElement;
  193. begin
  194.   try
  195.     New(SA);
  196.     try
  197.       RandomizeSA(SA);
  198.       Value := CalcPercentile(SA^, 0, MaxEIndex, LessThan,
  199.                               MaxEIndex div 2);
  200.       writeln('Median is ', Value:10:2);
  201.       Value := CalcPercentile(SA^, 0, MaxEIndex, LessThan,
  202.                               MaxEIndex div 20);
  203.       writeln('5% percentile is ', Value:10:2);
  204.       Value := CalcPercentile(SA^, 0, MaxEIndex, LessThan,
  205.                               (MaxEIndex * 19) div 20);
  206.       writeln('95% percentile is ', Value:10:2);
  207.  
  208.       UsualQuickSort(SA^, 0, MaxEIndex, LessThan);
  209.       writeln('Actual values using sorted array:');
  210.       writeln(SA^[MaxEIndex div 2]:10:2);
  211.       writeln(SA^[MaxEIndex div 20]:10:2);
  212.       writeln(SA^[(MaxEIndex*19) div 20]:10:2);
  213.     finally
  214.       Dispose(SA);
  215.     end;
  216.   except
  217.     on E: Exception do
  218.       writeln(E.Message);
  219.   end;
  220.   readln;
  221. end.
  222.